Optional Surfaces.f

Requires OpenGL
Requires SDL
Requires SDL-image
Requires Kagi
Requires Tools
Requires Seki
Requires Vectors

Only Forth Definitions

Also SDL-Surfaces

Variable colorkey \ internal

: sdl-dims  dup ->w @ swap ->h @ ;
: sdl-@width   sdl-dims drop ;
: sdl-@height   sdl-dims nip ;
: sdl-@components  ->format @ ->BytesPerPixel c@ ;
: sdl-has-alpha?  sdl-@components 4 = ;
: sdl-red-first?  ->format @ ->rmask @ $ff = ;
: sdl-texformat ( sdl-surface -- glformat )
   dup sdl-has-alpha? IF
      sdl-red-first? IF GL_RGBA ELSE GL_BGRA THEN
   ELSE
      sdl-red-first? IF GL_RGB ELSE GL_BGR THEN
   THEN ;
: sdl-pixel   ( surface x y --   addr )
   third ->w @ * + cells swap ->pixels @ + ;

\ Fetch color key from LAST pixel in SDL surface.
: @ck   ( sdl-surface -- sdl-surface )
   dup dup sdl-dims 1 1 2- sdl-pixel @ colorkey ! ;

\ create an alpha mask using colorkey.
: sdl-colorkey-alpha   ( sdl-surface -- sdl-surface )
   @ck dup dup 0 0 sdl-pixel swap sdl-dims * 0 do dup @ dup colorkey @ = if $ffffff and then !+ loop drop ;

: sdl-new  ( w h -- sdl-surface | false )
   dup if
      SDL_CreateRGBSurface( SDL_SWSURFACE -rot 32 $ff0000 $ff00 $ff $ff000000 )
   else
      nip
   then ;

: sdl-blit
   fourth 0 255 sdl_setalpha
   SDL_BlitSurface ;

: sdl-copy  ( sdl-surface1 -- sdl-surface2 )
  dup 0 255 SDL_SetAlpha
  dup sdl-dims sdl-new dup >r 0 swap 0 sdl-blit r> ;

: sdl-destroy
  SDL_FreeSurface ;

: sdl-make-32bit
  dup sdl-copy swap sdl-destroy ;

{
:[] temp-sdl-surface:[  ( w h xt -- ) ( sdl-surface -- )
  -rot sdl-new locals| s |
  s swap catch
    s sdl-destroy
  throw ;
}

: sdl-resize  ( sdl-surface1 w h -- sdl-surface2 ) \ doesn't delete surface1
   third 0 255 SDL_SetAlpha   sdl-new dup >r 0 swap 0 sdl-blit r> ;

: power/2 ( n -- n )
   1 begin over over > while 2* repeat nip ;

: sdl-power/2   ( sdl-surface1 -- sdl-surface2 )                  \ doesn't delete surface1
   dup sdl-dims power/2 swap power/2 swap sdl-resize ;


: sdl-texture ( sdl-surface -- texture )
   new-texture swap locals| tempsurf |
   glPixelStorei( GL_UNPACK_ROW_LENGTH  0 )
   glTexImage2D( GL_TEXTURE_2D  0   GL_RGBA8   tempsurf sdl-dims   0   tempsurf sdl-texformat   GL_UNSIGNED_BYTE   tempsurf 0 0 sdl-pixel ) ;

: delete-texture ( texure -- )
  ?dup if tx ! glDeleteTextures( 1 tx ) then ;

{
create clip1 8 /allot
create clip2 8 /allot

: ~h!+
   ~!+ 2 - ;

: 4h!
   >r swap 2swap swap r> ~h!+ ~h!+ ~h!+ ~h!+ drop ;

: sdl-blit  ( src x y w h dest x y w h -- )
   clip2 4h! >r clip1 4h!
   clip1 r> clip2 SDL_BlitSurface ;
}

: prepare-surface
   sdl-make-32bit sdl-colorkey-alpha
   dup sdl-power/2 swap sdl-destroy
   cr ." Converted surface: " dup sdl-dims swap . ." x " . ."  Colorkey: " colorkey @ h. ;

: sdl-update-texture ( surface sdlrect texture -- )
   locals| t rect s |
   t bind-texture
   glPixelStorei( GL_UNPACK_ROW_LENGTH s sdl-dims drop )
   glTexSubimage2D( GL_TEXTURE_2D  0  rect rect@  s sdl-texformat  GL_UNSIGNED_BYTE  s rect rect@ 2drop  sdl-pixel )  ;
